perm filename MAKNUM.F4[P11,LCS] blob
sn#573358 filedate 1981-03-15 generic text, type T, neo UTF8
00100 SUBROUTINE MAKNUM(RNUM)
00200 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
00300 1 /STF/RSTFAC(8),RSTJ2
00400 1 /NFONT/NFONT
00500 C*** PUT THIS IN AFTER ALPHA IS TRANSLATED
00600 EQUIVALENCE (J3,JQ(1)),(R4,RJQ(2)),(R8,RJQ(6)),(R7,RJQ(5))
00700 1,(R6,RJQ(4)),(R5,RJQ(3)),(R7,RJQ(5)),(JQ(15),B),(JQ(16),C)
00800 1 ,(J8,JQ(6)),(J10,JQ(8)),(R3,RJQ(1)),(J5,JQ(3)),(RJY,JQ(19))
00900 1 ,(J7,JQ(5)),(J6,JQ(4)),(R9,RJQ(7))
01000 DATA RS/10.0/,RBX/1.0/
01100 RB8=R8
01200 J3X=J3
01300 C P7=0=BDR40; =1=BDI40; =2=PRIM.
01400 IF(R6.GE.100.)R6=R6-100.
01500 IF(R6.EQ.0)R6=1.
01600 R5=R6
01700 C IF R6 > 100 IT'S FOR THE PAGE PROG. SUBTRACT 100 TO GET TRUE SIZE
01800 C IF IT'S 0 MAKE INTO 1.0 UPPER CASE - BDR40
01900 IF(R7.GT.2.)R7=0
02000 R6=48000000.0+(R7+50.)*10000.
02100 R7=99999999.0
02200 C BLANKS
02300 ONE=0
02400 IF(RNUM.NE.9999.)GO TO 2
02500 C NEXT FOR 'C'OMMON TIME
02600 RNUM=12.
02700 C MAKES A 'C'
02800 R4=R4-2.2
02900 C .2 FOR BAD POS. OF LETTERS
03000 GO TO 4
03100 2 RNUM=IFIX(RNUM)
03200 C SO MISTAKES (I.E. 2.2) WON'T BREAK THE PROG.
03300 IF(RNUM.EQ.1.)ONE=3.
03400 IF(RNUM.GT.9.)GO TO 3
03500 C JUMP FOR 2 OR 3 DIGIT NUMBER
03600 4 R6=R6+RNUM*100.+47.
03700 C PUTS BLANK ON END (.47)
03800 GO TO 1
03900 3 RJY=10.
04000 IF(RNUM.GE.100.)RJY=100.
04100 B=IFIX(RNUM/RJY)
04200 C=AMOD(RNUM,RJY)
04300 IF(RNUM.LT.100)GO TO 7
04400 D=IFIX(C/10.)
04500 C=AMOD(C,10.)
04600 IF(C.EQ.1.)ONE=ONE+3.
04700 R7=C*1000000.+999999.0
04800 C=D
04900 7 R6=R6+B*100.+C
05000 IF(B.EQ.1.)ONE=ONE+3.
05100 IF(C.EQ.1.)ONE=ONE+3.
05200 B=R5
05300 IF(RNUM.GE.100.)B=B*2
05400 J3=J3-RS*RSTJ2*B
05500 C FOR 2 DIGIT NUMBER ADJUSTS FOR 11, ETC.
05600 1 J3=J3+ONE*R5*RSTJ2
05700 C CENTERS THE NUMBER '1'
05800 MFONT=NFONT
05900 CALL ALPHA
06000 NFONT=MFONT
06100 C RESTORE FONT TO WHATEVER IT WAS BEFORE
06200 J3=J3X
06300 IF(RB8.EQ.0)RETURN
06400 C NEXT FOR CIRCLES AND BOXES AROUND NUMBERS.
06500 R3=J3-R5
06600 IF(J10.EQ.0)J10=1
06700 C USE J10 FOR EVEN THICKER BOX AND CIRC.
06800 IF(RNUM.GT.9)R3=R3+R5*RBX
06900 C TO SET CENTER
07000 IF(RB8.EQ.2.)GO TO 5
07100 R4=R4+R5+.1+.05/R5
07200 C END OF ABOVE IS FOR SMALL CIRCLES.
07300 B=4.5
07400 IF(RNUM.GE.100.)B=5.5
07500 R5=R5*B
07600 J6=0
07700 J7=0
07800 J8=J10
07900 CALL CENTX
08000 CALL CIRCLE
08100 RETURN
08200 5 B=6.
08300 R9=0
08400 IF(RNUM.LT.100.)GO TO 8
08500 B=9.
08600 R9=R5*6.
08700 C MAKES RECTANGLE IF >=100
08800 8 R4=R4+R5*.7+.1
08900 R8=R5*B
09000 J5=50
09100 R3=R3+1.0
09200 C SHIFT BOX SLIGHTLY TO RIGHT
09300 CALL ITMSUB
09400 END